Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/Chat 1.1.0/source/Chat.p

Text File | 1992-11-28 | 14.7 KB | 623 lines | [TEXT/PJMM]

{$I-}
program Chat;

{ This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }
{ You may use this source in your own free/shareware projects as long as you acknowledge me }
{ in your About box and documentation files.  You may include it in commercial products }
{ only if I explicitly allow it. }

    uses
        TCPStuff, TCPConnections, MyTypes, MyUtils, MyLists, MyStripTelnetCodes;

    const
        globalStrhResID = 128;
        channelStrhResID = 129;
        commandStrhResID = 130;
        max_channel = 10;
        bad_rn = -1;

    type
        strings = (noIndex, portIndex, irclogname, irclogtype, quitnowIndex, {}
            howdullIndex, welcomeIndex, badChannelIndex, enternameIndex,{}
            loggedinatIndex, youneedanameIndex, nameinuseIndex,{}
            welcome2index1, welcomewarningIndex, welcome2index2, hasenteredIndex, {}
            closingdownIndex, closingdownatIndex, helpIndex, helpIndex2,{}
            byebyeIndex, colonIndex, hasleftIndex,{}
            echoIndex, badparamIndex, badvariableIndex, {}
            lastIndex);
        commands = (C_None, C_Quit, C_List, C_Action1, C_Action2, C_Set);

    type
        infoRecord = record
                cp: connectionIndex;
                tp: TCPConnectionPtr;
                state: (S_unconnected, S_GettingChannel, S_GettingName, S_GettingPassword, S_Connected, S_Closed);
                buffer: str255;
                name: str31;
                channel: str31;
                channel_index: integer;
                wason: boolean;
                echotoyou: boolean;
                requirequote: boolean;
            end;
        infoPtr = ^infoRecord;

    var
        lh: listHead;
        quitNow: boolean;
        connected: integer;
        port: integer;
        dolog: boolean;
        logrns: array[1..max_channel] of integer;

    function GetGlobalString (n: strings): str255;
        var
            s: str255;
    begin
        GetIndString(s, globalStrhResID, ord(n));
        GetGlobalString := s;
    end;

    procedure CreatePC;
        var
            p: infoPtr;
            oe: OSErr;
    begin
        p := infoPtr(Newptr(SizeOf(infoRecord)));
        p^.state := S_unconnected;
        p^.channel := '';
        p^.channel_index := 0;
        p^.wason := false;
        p^.echotoyou := false;
        p^.requirequote := false;
        oe := NewPassiveConnection(p^.cp, Minimum_TCPBUFFERSIZE, port, 0, 0, p);
        AddTail(lh, p);
    end;

    procedure DestroyPC (p: infoPtr);
        var
            item: listItem;
            lp: infoPtr;
    begin
        if FindItem(lh, p, item) then begin
            DisposPtr(ptr(p));
            DeleteItem(item, p);
        end;
    end;

    procedure StartLog (var info: infoRecord; name: str255);
        var
            oe, ooe: OSErr;
            logrn: integer;
    begin
        oe := HCreate(-1, 2, name, GetGlobalString(irclogtype), 'TEXT');
        oe := HOpen(-1, 2, name, fsWrPerm, logrn);
        if oe = noErr then begin
            oe := SetFPos(logrn, fsFromLEOF, 0);
            if oe <> noErr then
                ooe := FSClose(logrn);
        end;
        if oe = noErr then
            logrns[info.channel_index] := logrn;
    end;

    procedure StopLog (var info: infoRecord);
        var
            oe: OSErr;
    begin
        if logrns[info.channel_index] <> bad_rn then begin
            oe := FSClose(logrns[info.channel_index]);
            logrns[info.channel_index] := bad_rn;
        end;
    end;

    procedure StopAllLogs;
        var
            oe: OSErr;
            i: integer;
    begin
        for i := 1 to max_channel do
            if logrns[i] <> bad_rn then
                oe := FSClose(logrns[i]);
    end;

    procedure Log (var info: infoRecord; s: str255);
        var
            count: longInt;
            oe: OSErr;
    begin
{$PUSH}
{$R-}
        if s[length(s)] = lf then
            s[0] := chr(ord(s[0]) - 1);
        count := length(s);
        oe := FSWrite(logrns[info.channel_index], count, @s[1]);
{$POP}
    end;

    function EnterChannel (var info: infoRecord): boolean;
        var
            i: integer;
            s: str255;
    begin
        i := 1;
        info.channel_index := 0;
        GetIndString(s, channelStrhResID, i * 2 - 1);
        while (i <= max_channel) & (s <> '') do begin
            if IUEqualString(s, info.channel) = 0 then begin
                info.channel_index := i;
                if logrns[i] = bad_rn then begin
                    GetIndString(s, channelStrhResID, i * 2);
                    if s <> '' then begin
                        StartLog(info, s);
                    end;
                end;
                leave;
            end;
            i := i + 1;
            GetIndString(s, channelStrhResID, i * 2 - 1);
        end;
        EnterChannel := info.channel_index > 0;
    end;

    procedure LeaveChannel (var p: infoPtr);
        var
            item: listItem;
            lp: infoPtr;
            someoneelse: boolean;
    begin
        if p^.channel_index <> 0 then begin
            someoneelse := false;
            ReturnHead(lh, item);
            while not IsTail(item) do begin
                Fetch(item, lp);
                if (lp <> p) & (lp^.channel_index = p^.channel_index) then begin
                    someoneelse := true;
                    leave;
                end;
                MoveToNext(item);
            end;
            if not someoneelse then
                StopLog(p^);
        end;
    end;

    function GetLine (tcpc: TCPConnectionPtr; value: longInt; var buffer: str255): boolean;
        var
            len: longInt;
            gotlf: boolean;
            i, j: integer;
    begin
        GetLine := false;
        len := length(buffer);
{$PUSH}
{$R-}
        if TCPReceiveUpTo(tcpc, 10, 1, @buffer[1], SizeOf(buffer) - 1, len, gotlf) = noErr then begin
            i := 1;
            j := 1;
            while (i <= len) do begin
                case buffer[i] of
                    cr, lf:
                        i := i + 1;
                    bs, del:  begin
                        i := i + 1;
                        if j > 1 then
                            j := j - 1;
                    end;
                    otherwise begin
                        buffer[j] := buffer[i];
                        i := i + 1;
                        j := j + 1;
                    end;
                end;
            end;
            buffer[0] := chr(j - 1);
            GetLine := gotlf;
        end;
{$POP}
    end;

    procedure SendString (tcpc: TCPCOnnectionPtr; s: str255);
        var
            oe: OSErr;
    begin
{$PUSH}
{$R-}
        oe := TCPSendAsync(tcpc, @s[1], length(s), true, nil);
{$POP}
    end;

    function OtherOnChannel (p, lp: infoPtr): boolean;
    begin
        OtherOnChannel := (lp <> p) & (lp^.state = S_connected) & (lp^.channel_index = p^.channel_index);
    end;

    function WeakOtherOnChannel (p, lp: infoPtr): boolean;
    begin
        WeakOtherOnChannel := ((lp <> p) or (p^.echotoyou)) & (lp^.state = S_connected) & (lp^.channel_index = p^.channel_index);
    end;

    procedure SendExceptString (p: infoPtr; s: str255);
        var
            item: listItem;
            lp: infoPtr;
            tcpc: TCPConnectionPtr;
    begin
        Log(p^, s);
        ReturnHead(lh, item);
        while not IsTail(item) do begin
            Fetch(item, lp);
            if WeakOtherOnChannel(p, lp) then begin
                GetConnectionTCPC(lp^.cp, tcpc);
                SendString(tcpc, s);
            end;
            MoveToNext(item);
        end;
    end;

    type
        SEFormat = (SE_Speak, SE_Action, SE_Notice);

    procedure SendExceptNameString (p: infoPtr; s: str255; format: SEFormat);
        var
            colon: str15;
            i, linelen: integer;
            out: str255;
    begin
        case format of
            SE_Speak:
                colon := ': ';
            SE_Action:
                colon := ' ';
            SE_Notice:
                colon := ' ';
        end;
        linelen := 72 - length(colon) - length(p^.name);
        for i := 1 to length(s) do
            if s[i] = tab then
                s[i] := spc;
        repeat
            if length(s) > 78 - length(colon) - length(p^.name) then begin
                i := linelen;
                while (i > 0) and (s[i] <> spc) do begin
                    i := i - 1;
                end;
                while (i > 0) and (s[i] = spc) do begin
                    i := i - 1;
                end;
                if i < 1 then
                    i := linelen;
            end
            else
                i := length(s);
            out := concat(p^.name, colon, copy(s, 1, i));
            if format = SE_Notice then
                out := concat('*', out, '*');
            SendExceptString(p, concat(out, cr, lf));
            i := i + 1;
            while (i <= length(s)) and (s[i] = spc) do begin
                i := i + 1;
            end;
            s := copy(s, i, 255);
        until s = '';
    end;

    procedure FixName (var s: str31);
        var
            i: integer;
    begin
        for i := 1 to length(s) do
            if not (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '-', '$', '/']) then
                s[i] := '_';
    end;

    function NameInUse (p: infoPtr): boolean;
        var
            item: listItem;
            lp: infoPtr;
            tcpc: TCPConnectionPtr;
    begin
        NameInUse := false;
        ReturnHead(lh, item);
        while not IsTail(item) do begin
            Fetch(item, lp);
            if OtherOnChannel(p, lp) then begin
                if IUEqualString(lp^.name, p^.name) = 0 then begin
                    NameInUse := true;
                    leave;
                end;
            end;
            MoveToNext(item);
        end;
    end;

    procedure SendExceptNames (p: infoPtr);
        var
            item: listItem;
            lp: infoPtr;
            first: boolean;
            len: integer;
    begin
        first := true;
        len := 0;
        ReturnHead(lh, item);
        while not IsTail(item) do begin
            Fetch(item, lp);
            if OtherOnChannel(p, lp) then begin
                if first then
                    first := false
                else begin
                    SendString(p^.tp, ', ');
                    len := len + 2;
                end;
                if len + length(lp^.name) > 75 then begin
                    SendString(p^.tp, concat(cr, lf));
                    len := 0;
                end;
                SendString(p^.tp, lp^.name);
                len := len + length(lp^.name);
            end;
            MoveToNext(item);
        end;
        if first then
            SendString(p^.tp, concat(GetGlobalString(howdullIndex), cr, lf))
        else
            SendString(p^.tp, concat(cr, lf));
    end;

    function GetTimeStr: str255;
        var
            st, sd: str255;
            date: longInt;
    begin
        GetDateTime(date);
        IUDateString(date, abbrevDate, sd);
        IUTimeString(date, false, st);
        GetTimeStr := concat(st, ', ', sd);
    end;

    procedure GetWord (var line, word: str255);
        var
            p: integer;
    begin
        p := Pos(' ', line);
        if p > 0 then begin
            word := copy(line, 1, p - 1);
            Delete(line, 1, p);
        end
        else begin
            word := line;
            line := '';
        end;
    end;

    function SetBoolean (var line: str255; var b: boolean): boolean;
    begin
        UpCaseString(line);
        SetBoolean := false;
        if line <> '' then begin
            case line[1] of
                'Y', 'E', 'T':  begin
                    b := true;
                    SetBoolean := true;
                end;
                'N', 'D', 'F':  begin
                    b := false;
                    SetBoolean := true;
                end;
                'O':  begin
                    if line = 'ON' then begin
                        b := true;
                        SetBoolean := true;
                    end
                    else if line = 'OFF' then begin
                        b := false;
                        SetBoolean := true;
                    end;
                end;
                otherwise
                    ;
            end;
        end;
    end;

    procedure DoCommand (var p: infoPtr; line: str255);
        var
            ch: char;
            i, ps: integer;
            cmd: commands;
            s, thecmd: str255;
    begin
        ch := nul;
        if line <> '' then
            ch := line[1];
        case ch of
            '/':  begin
                Delete(line, 1, 1);
                if line = GetGlobalString(quitnowIndex) then begin
                    quitNow := true;
                    SendString(p^.tp, concat(GetGlobalString(closingdownIndex), cr, lf));
                    SendExceptString(p, concat(GetGlobalString(closingdownatIndex), GetTimeStr, cr, lf));
{ Should really send to everyone everywhere, but too much effort }
                end
                else begin
                    GetWord(line, thecmd);
                    i := 1;
                    cmd := C_None;
                    GetIndString(s, commandStrhResID, i * 2 - 1);
                    while s <> '' do begin
                        if IUEqualString(thecmd, s) = 0 then begin
                            cmd := commands(i);
                            leave;
                        end;
                        i := i + 1;
                        GetIndString(s, commandStrhResID, i * 2 - 1);
                    end;
                    case cmd of
                        C_Quit:  begin
                            SendString(p^.tp, concat(GetGlobalString(byebyeIndex), cr, lf));
                            p^.echotoyou := false;
                            p^.state := S_Closed;
                            CloseConnection(p^.cp);
                        end;
                        C_List:  begin
                            SendExceptNames(p);
                        end;
                        C_Action1, C_Action2:  begin
                            SendExceptNameString(p, line, SE_Action);
                        end;
                        C_Set:  begin
                            GetWord(line, thecmd);
                            if IUEqualString(thecmd, GetGlobalString(echoIndex)) = 0 then begin
                                if not SetBoolean(line, p^.echotoyou) then
                                    SendString(p^.tp, concat(GetGlobalString(badparamIndex), cr, lf));
                            end
                            else begin
                                SendString(p^.tp, concat(GetGlobalString(badvariableIndex), cr, lf));
                            end;
                        end;
                        otherwise begin
                            SendString(p^.tp, concat(GetGlobalString(helpIndex), cr, lf));
                            i := 1;
                            GetIndString(s, commandStrhResID, i * 2);
                            while s <> '' do begin
                                if s <> '<NONE>' then
                                    SendString(p^.tp, concat(s, cr, lf));
                                i := i + 1;
                                GetIndString(s, commandStrhResID, i * 2);
                            end;
                            SendString(p^.tp, concat(GetGlobalString(helpIndex2), cr, lf));
                        end;
                    end;
                end;
            end;
            otherwise begin
                SendExceptNameString(p, line, SE_Speak);
            end;
        end;
    end;

    procedure WNE;
        var
            dummy: boolean;
            er: eventRecord;
    begin
        dummy := WaitNextEvent(everyEvent, er, 15, nil);
        if er.what = keyDown then
            quitNow := true;
    end;

    function StackPtr: longInt;
    inline
        $2E8F;

    var
        cer: connectionEventRecord;
        p: infoPtr;
        oe: OSErr;
        dummylong: longInt;
        i: integer;
        last: str255;
begin
    SetApplLimit(ptr(StackPtr - 10000));
    MaxApplZone;
    MoreMasters;
    if GetGlobalString(lastIndex) = '<LAST>' then begin
        StringToNum(GetGlobalString(portIndex), dummylong);
        port := dummylong;
        for i := 1 to max_channel do
            logrns[i] := bad_rn;

        if InitConnections = noErr then begin
            CreateList(lh);
            CreatePC;
            CreatePC;
            connected := 0;
            while not quitNow do begin
                WNE;
                if GetConnectionEvent(any_connection, cer) then
                    with cer do begin
                        p := infoPtr(dataptr);
                        with p^ do
                            case event of
                                C_Established:  begin
                                    connected := connected + 1;
                                    state := S_GettingChannel;
                                    buffer := '';
                                    tp := tcpc;
                                    SendString(tcpc, GetGlobalString(welcomeIndex));
                                    CreatePC;
                                end;
                                C_CharsAvailable:  begin
                                    if GetLine(tcpc, value, buffer) then begin
                                        StripTelnetCodes(buffer);
                                        case state of
                                            S_GettingChannel:  begin
                                                channel := buffer;
                                                if EnterChannel(p^) then begin
                                                    SendString(tcpc, GetGlobalString(enternameIndex));
                                                    state := S_GettingName;
                                                end
                                                else begin
                                                    SendString(tcpc, concat(GetGlobalString(badChannelIndex), cr, lf));
                                                    state := S_Closed;
                                                    CloseConnection(connection);
                                                end;
                                            end;
                                            S_GettingName:  begin
                                                Log(p^, concat(buffer, GetGlobalString(loggedinatIndex), GetTimeStr, cr, lf));
                                                name := buffer;
                                                FixName(name);
                                                if name = '' then begin
                                                    SendString(tcpc, concat(GetGlobalString(youneedanameIndex), cr, lf));
                                                    state := S_Closed;
                                                    CloseConnection(connection);
                                                end
                                                else if NameInUse(p) then begin
                                                    SendString(tcpc, concat(GetGlobalString(nameinuseIndex), cr, lf));
                                                    state := S_Closed;
                                                    CloseConnection(connection);
                                                end
                                                else begin
                                                    SendString(tcpc, GetGlobalString(welcome2index1));
                                                    if logrns[channel_index] <> bad_rn then
                                                        SendString(tcpc, GetGlobalString(welcomewarningIndex));
                                                    SendString(tcpc, GetGlobalString(welcome2index2));
                                                    state := S_connected;
                                                    SendExceptNames(p);
                                                    SendExceptNameString(p, GetGlobalString(hasenteredIndex), SE_Notice);
                                                    wason := true;
                                                end;
                                            end;
                                            S_GettingPassword:  begin
                                            end;
                                            S_Connected:  begin
                                                DoCommand(p, buffer);
                                            end;
                                            otherwise
                                                ;
                                        end;{case}
                                        buffer := '';
                                    end;{if getline}
                                    StripTelnetCodes(buffer);
                                end;
                                C_Closing:  begin
                                    state := S_Closed;
                                    CloseConnection(connection);
                                end;
                                C_Closed:  begin
                                    if wason then
                                        SendExceptNameString(p, GetGlobalString(hasleftIndex), SE_Notice);
                                    if channel_index > 0 then
                                        LeaveChannel(p);
                                    connected := connected - 1;
                                    DestroyPC(p);
                                end;
                            end;
                    end;
            end;
            FinishEverything;
        end;
    end;
    StopAllLogs;
end.